Especial Multimedia/Especial Multimedia.iso/Multimed/Prg/WAVPLUS.ZIP/DPLIBSTR.BA_/DPLIBSTR.BA

Text File | 1997-09-14 | 13KB | 427 lines

'DPLIBSTR.BAS
'1/16/95
'Digital PowerTOOLS Library for Strings
'Copyright ⌐ 1995 by Digital PowerTOOLS

'these functions and subroutines are intended ONLY for use
'in your application; you are not authorized to distribute
'this source code

Function AmpersandFix (ThisString)
'doubles each occurence of an ampersand in the string
'this enables the string to display ampersands (&) correctly in ListBoxes and Labels
'VB converts single ampersands to underscores in ListBoxes and Labels

    Temp$ = ""
    WorkString$ = ThisString

    While InStr(WorkString$, "&")
        n% = InStr(WorkString$, "&")
        Temp$ = Temp$ + Left$(WorkString$, n%) + "&"
        WorkString$ = Mid$(WorkString$, n% + 1)
        Wend
    Temp$ = Temp$ + WorkString$
    AmpersandFix = Temp$
End Function

Function AmpersandUnFix (x)
'if you use AmpersandFix to display ListBox strings correctly,
'you need to use AmpersandUnfix to remove the double ampersands
'when using ListBox.List(x) to return the correct string value
'for example, UserSelection=AmpersandUnfix(List1.List(List1.ListIndex))

    Dim z As String

    If Len(x) < 1 Then
        AmpersandUnFix = ""
        Exit Function
        End If

    z = x
    pos% = InStr(z, "&&")
    Do Until pos% = 0
        z = Left$(z, (pos%)) + Right$(z, Len(z) - Len(y) - pos% - 1)
        pos% = InStr(z, "&&")
        Loop
    AmpersandUnFix = z
End Function

Function BackSlashAdd (ThePath)
'adds a backslash (\) to a string, only if the rightmost
'character is not already a backslash

    ThisPath$ = ThePath
    If Right$(ThisPath$, 1) <> "\" Then
        ThisPath$ = ThisPath$ + "\"
        End If
    BackSlashAdd = ThisPath$
End Function

Function BackSlashSub (ThePath)
'removes the end backslash from a string, if the string is
'more than three characters in length (not root directory)

    ThisPath$ = ThePath
    If Right$(ThisPath$, 1) = "\" And Len(ThisPath$) > 3 Then
        ThisPath$ = Left$(ThisPath$, Len(ThisPath$) - 1)
        End If
    BackSlashSub = ThisPath$
End Function

Function Compare (FirstOne, SecondOne)
'performs a case-insensitive comparison of two strings
'returns -1 (TRUE) if identical, returns 0 (false) otherwise

    ThisFirstOne = UCase$(FirstOne)
    ThisSecondOne = UCase$(SecondOne)
    Compare = False

    If ThisFirstOne = ThisSecondOne Then
        Compare = True
        End If

End Function

Function InstrReverse (Incoming, SearchFor)
'the opposite of Instr function
'searches from the END of a string for the first occurence
'of SearchFor in Incoming

    If Len(Incoming) = 0 Or Len(SearchFor) = 0 Then
        InstrReverse = 0
        Exit Function
        End If

    IncomingRev = Reverse(Incoming)
    SearchForRev = Reverse(SearchFor)
    pos% = InStr(IncomingRev, SearchForRev)
    If pos% <> 0 Then
        pos% = Len(IncomingRev) - pos% + 1
        End If
    InstrReverse = pos%

End Function

Function IsLower (Incoming)
'returns -1 (TRUE) if the first character of Incoming is lower case
'return 0 (FALSE) if not lower case

    IsLower = False
    If Len(Incoming) = 0 Then Exit Function

    If Left$(Incoming, 1) >= "a" And Left$(Incoming, 1) <= "z" Then
        IsLower = True
        End If

End Function

Function IsPathValid (FullPath)
'determines if the path is a valid DOS path string
'returns -1 (TRUE) if valid, otherwise returns 0 (FALSE)

    If Len(FullPath) < 3 GoTo InvalidPath
    If (InStr(FullPath, "*") <> 0) GoTo InvalidPath
    If (InStr(FullPath, "?") <> 0) GoTo InvalidPath
    If (InStr(FullPath, " ") <> 0) GoTo InvalidPath
    If Mid$(FullPath, 2, 1) <> ":" GoTo InvalidPath
    If UCase$(Left$(FullPath, 1)) < "A" Or UCase$(Left$(FullPath, 1)) > "Z" GoTo InvalidPath

    If Len(FullPath) > 2 Then
        If Mid$(FullPath, 3, 1) <> "\" Then
            FullPath = Left$(FullPath, 2) + "\" + Right$(FullPath, Len(FullPath) - 2)
            End If
        End If

    If Len(FullPath) = 3 Then
        If Right$(DefaultPath$, 2) = ":\" GoTo ValidPath
        End If

    If InStr(FullPath, "\\") <> 0 Then GoTo InvalidPath

    FullPath = BackSlashAdd(FullPath)
    LegalChar$ = "!#$%&'()-0123456789@ABCDEFGHIJKLMNOPQRSTUVWXYZ^_`{}~.ⁿΣ÷─╓▄▀"
    BackPos = 3
    ForePos = InStr(4, FullPath, "\")
    Do
        Temp$ = Mid$(FullPath, BackPos + 1, ForePos - BackPos - 1)
        For i = 1 To Len(Temp$)
            If InStr(LegalChar$, UCase$(Mid$(Temp$, i, 1))) = 0 Then GoTo InvalidPath
            Next i
        PeriodPos = InStr(Temp$, ".")
        Length = Len(Temp$)
        If PeriodPos = 0 Then
            If Length > 8 Then GoTo InvalidPath
            Else
            If PeriodPos > 9 Then GoTo InvalidPath
            If Length > PeriodPos + 3 Then GoTo InvalidPath
            If InStr(PeriodPos + 1, Temp$, ".") <> 0 Then GoTo InvalidPath
            End If
        BackPos = ForePos
        ForePos = InStr(BackPos + 1, FullPath, "\")
    Loop Until ForePos = 0

    EndChar$ = Mid$(FullPath, Len(FullPath) - 1, 1)
    If EndChar$ = "." And Mid$(FullPath, Len(FullPath) - 2, 1) = "\" GoTo InvalidPath

ValidPath:
    IsPathValid = True
    FullPath = BackSlashSub(FullPath)
    Exit Function
InvalidPath:
    IsPathValid = False
    FullPath = BackSlashSub(FullPath)
    Exit Function
End Function

Function IsUpper (Incoming)
'returns -1 (TRUE) if the first character of Incoming is upper case
'return 0 (FALSE) if not upper case

    IsUpper = False
    If Len(Incoming) = 0 Then Exit Function

    If Left$(Incoming, 1) >= "A" And Left$(Incoming, 1) <= "Z" Then
        IsUpper = True
        End If

End Function

Function JustifyLeft (Incoming, PadChar, TotalWidth)
'left justifies Incoming$ within TotalWidth% characters using PadChar$ as the pad character
'if Incoming$ is longer than TotalWidth% it is truncated to TotalWidth% characters

    If Len(Incoming) = TotalWidth Then
        JustifyLeft = Incoming
        Exit Function
        End If

    If Len(Incoming) > TotalWidth Then
        JustifyLeft = Left$(Incoming, TotalWidth)
        Exit Function
        End If

    If Len(PadChar) = 0 Then PadChar = " "
    AddAmount% = TotalWidth - Len(Incoming)
    JustifyLeft = Incoming + String(AddAmount%, Left$(PadChar, 1))

End Function

Function JustifyRight (Incoming, PadChar, TotalWidth)
'right justifies Incoming$ within TotalWidth% characters using PadChar$ as the pad character
'if Incoming$ is longer than TotalWidth% it is truncated to TotalWidth% characters

    If Len(Incoming) = TotalWidth Then
        JustifyRight = Incoming
        Exit Function
        End If

    If Len(Incoming) > TotalWidth Then
        JustifyRight = Left$(Incoming, TotalWidth)
        Exit Function
        End If

    If Len(PadChar) = 0 Then PadChar = " "
    AddAmount% = TotalWidth - Len(Incoming)
    JustifyRight = String(AddAmount%, Left$(PadChar, 1)) + Incoming

End Function

Function PadLeft (Incoming, PadChar, Count)
'pads a string (on the left side) with Count% copies of PadChar$
'in most situations, PadChar$ will be a blank space
'for example, PadLeft("Now is the","X",4) will return "XXXXNow is the")

    If Len(PadChar) = 0 Then PadChar = " "
    PadLeft = String$(Count, Left$(PadChar, 1)) + Incoming
End Function

Function PadRight (Incoming, PadChar, Count)
'pads a string (on the right side) with Count% copies of PadChar$
'in most situations, PadChar$ will be a blank space
'for example, PadRight("Now is the","X",4) will return "Now is theXXXX")

    If Len(PadChar) = 0 Then PadChar = " "
    PadRight = Incoming + String$(Count, Left$(PadChar, 1))
End Function

Function PathDots (FullPath, MaxLength)
'if the length of FullPath is greater than MaxLenth characters,
'dots are inserted into the middle of Full Path

'works best if MaxLength is greater than 18 characters
'(this allows for filename, drive, and leading backslash

    Dim TempString As String

    WorkString = FullPath
    WorkString2 = FullPath
    ThisLength = MaxLength

    If Len(WorkString) <= ThisLength Then
        PathDots = WorkString
        Exit Function
        End If

    pos% = InStr(WorkString2, "\")
    If pos% <> 0 Then
        WorkString2 = Right$(WorkString2, Len(WorkString2) - pos%)
        NextPos% = InStr(WorkString2, "\")
        If NextPos% <> 0 Then pos% = NextPos% + pos%
        End If
    If pos% = 0 Then pos% = 3

    ThisLength = ThisLength - pos%
    For i = Len(WorkString) - ThisLength To Len(WorkString)
        If Mid$(WorkString, i, 1) = "\" Then Exit For
        Next i

    PathDots = Left$(WorkString, pos%) + "..." + Right$(WorkString, Len(WorkString) - (i - 1))
End Function

Function PathDotsRight (FullPath, MaxLength)
'truncates a path to MaxLength characters with three trailing elipsis points

    WorkString = FullPath
    If Len(FullPath) < MaxLength Or MaxLength < 4 Then
        PathDotsRight = FullPath
        Exit Function
        End If

    PathDotsRight = Left$(WorkString, MaxLength - 3) + "..."

End Function

Function replace (x, y, ReplaceString)
'replaces ALL occurences of y$ within x$ with ReplaceString
'for example, strip("abcdefabcedf","cde") = "abfabf"

    Dim z As String

    If Len(x) < 1 Or Len(y) < 1 Then
        replace = ""
        Exit Function
        End If

    If Len(ReplaceString) = 0 Then
        replace = x
        Exit Function
        End If

    z = x
    pos% = InStr(z, y)
    Do Until pos% = 0
        z = Left$(z, (pos% - 1)) + ReplaceString + Right$(z, Len(z) - Len(y) - pos% + 1)
        pos% = InStr(z, y)
        Loop
    replace = z
End Function

Function Reverse (Incoming)
'Reverses the character sequence of a string

    WorkString = ""
    If Len(Incoming) = 0 Then
        Reverse = ""
        Exit Function
        End If

    For i = Len(Incoming) To 1 Step -1
        WorkString = WorkString + Mid$(Incoming, i, 1)
        Next i
    Reverse = WorkString
End Function

Function SplitLines (TextMsg, MaxCharsPerLine)
'splits a long string into multiple lines with hard returns

    counter% = 0
    NewTextMsg$ = ""

    If MaxCharsPerLine < 15 Then
        SplitLines = TextMsg
        Exit Function
        End If

    If Len(TextMsg) < MaxCharsPerLine Then
        SplitLines = TextMsg
        Exit Function
        End If

    While Len(TextMsg) > MaxCharsPerLine
        If InStr(TextMsg, Chr$(13)) > MaxCharsPerLine Or InStr(TextMsg, Chr$(13)) = 0 Then
            counter% = MaxCharsPerLine
            While Mid$(TextMsg, counter%, 1) <> " " And counter% > 1
                counter% = counter% - 1
                Wend
            If counter% = 1 Then counter% = MaxCharsPerLine
            NewTextMsg$ = NewTextMsg$ + Left$(TextMsg, counter%) + nl
            TextMsg = Right$(TextMsg, Len(TextMsg) - counter%)
            Else
            NewTextMsg$ = NewTextMsg$ + Left$(TextMsg, InStr(TextMsg, Chr$(13)) - 1) + nl
            TextMsg = Right$(TextMsg, Len(TextMsg) - (InStr(TextMsg, Chr$(13)) + 1))
            End If
        Wend
    SplitLines = NewTextMsg$ + TextMsg
End Function

Function Strip (x, y)
'strips ALL occurences of y$ within x$
'for example, strip("abcdefabcedf","cde") = "abfabf"

    Dim z As String

    If Len(x) < 1 Or Len(y) < 1 Then
        Strip = ""
        Exit Function
        End If

    z = x
    pos% = InStr(z, y)
    Do Until pos% = 0
        z = Left$(z, (pos% - 1)) + Right$(z, Len(z) - Len(y) - pos% + 1)
        pos% = InStr(z, y)
        Loop
    Strip = z
End Function

Function stuff (Incoming, AddString, Offset)
'inserts AddString into Incoming at character position Offset
'if Offset=len(Incoming)+1 then AddString is just added to the end of Incoming

    If Offset < 1 Or Offset > Len(Incoming) + 1 Then
        stuff = Incoming
        Exit Function
        End If

    Offset = Offset - 1
    LeftSide$ = Left$(Incoming, Offset)
    RightSide$ = Right$(Incoming, Len(Incoming) - Offset)

    stuff = LeftSide$ + AddString + RightSide$

End Function

Sub Swap (x, y)
'swaps the values of two variables
'works with numeric variables too

    Dim z As Variant

    z = x
    x = y
    y = z
End Sub

Function TrimAtNull (TheWord)
'Trims the string at the NULL character
'useful with most DLL's that change a string's value

    pos% = InStr(TheWord, Chr$(0))
    If pos% = 0 Then
        TrimAtNull = TheWord
        Else
        TrimAtNull = Left$(TheWord, pos% - 1)
        End If
End Function